COMMENT ⊗   VALID 00004 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	{$NOMAIN	Expression Parser }
C00005 00003	(* aux routines for parsing expressions(cont): getargs *)
C00019 00004	(* function to parse expressions: exprParse *)
C00036 ENDMK
C⊗;
{$NOMAIN	Expression Parser }

%include palhdr.pas;

{ Externally defined routines from elsewhere: }

	(* From ALLOC *)
function newNode: nodep;					external;
procedure relNode(n: nodep);					external;

	(* From PROOT *)
procedure errprnt;						external;
procedure getToken;						external;
procedure getDelim(char: ascii);				external;

	(* From PAUX1 *)
function varLookup(id: identp): varidefp;			external;
function makeUVar(vartype: datatypes; vid: identp): varidefp;	external;
function defNode(d: datatypes): nodep;				external;
function getDtype(n: nodep): datatypes;				external;
function checkArg(n: nodep; d: datatypes): nodep;		external;
function copyExpr(n: nodep; lcp: boolean): nodep;		external;

	(* From PAUX2 *)
function getdim(n: nodep; var d: nodep): nodep;			external;
procedure checkdim(n,d: nodep);					external;

	(* Display-related Routines *)
procedure ppLine; 						external;
procedure ppOutNow; 						external;
procedure ppChar(ch: ascii); 					external;
procedure pp5(ch: c5str; length: integer); 			external;
procedure pp10(ch: cstring; length: integer); 			external;
procedure pp10L(ch: cstring; length: integer);			external;
procedure pp20(ch: c20str; length: integer); 			external;
procedure pp20L(ch: c20str; length: integer); 			external;
procedure ppInt(i: integer); 					external;
procedure ppReal(r: real); 					external;
procedure ppStrng(length: integer; s: strngp); 			external;

(* aux routines for parsing expressions(cont): getargs *)

function exprParse: nodep; external;	{and also FORWARD}

procedure getargs(opn: nodep); external;
procedure getargs;
var arg,n,np,nhdr,d: nodep; nargs,i: integer; dch: ascii; dat: datatypes;
    absp,aref,func,qp,closep,b,bp: boolean; paramlist,v: varidefp;

 procedure check1(d: datatypes);
  begin
  opn↑.arg1 := checkarg(opn↑.arg1,d); (* check datatype is right *)
  end;

 procedure check2(d1,d2: datatypes);
  begin
  with opn↑ do
   begin
   arg1 := checkarg(arg1,d1);	  (* check datatype is right for first arg *)
   arg2 := checkarg(arg2,d2);	  (* and also check second *)
   end;
  end;

 procedure check3(d1,d2,d3: datatypes);
  begin
  with opn↑ do
   begin
   arg1 := checkarg(arg1,d1);	  (* check datatype is right for first arg *)
   arg2 := checkarg(arg2,d2);	  (* and also check second *)
   arg3 := checkarg(arg3,d3);	  (* and also check third *)
   end;
  end;

begin
with opn↑ do
 begin
 if not ((op=arefop) or (op=callop)) then arg1 := nil;
 arg2 := nil;
 arg3 := nil
 end;
if (opn↑.op = grinchop) then			(* grinch is special *)
  begin
  if curMotion <> nil then
    opn↑.arg1 := copyExpr(curMotion↑.cf,true)	(* copy control frame *)
   else
    begin
    pp20L('Grinch can only occu',20); pp20('r in a motion statem',20);
    pp5('ent  ',3);
    errprnt;
    opn↑.op := badop;
    opn↑.arg1 := newNode;
    opn↑.arg2 := defNode(transtype);
    with opn↑.arg1↑ do
     begin
     ntype := exprnode;
     op := grinchop;
     arg1 := opn↑.arg2;
     arg2 := nil;
     arg3 := nil;
     end
    end
  end
 else if (opn↑.op <> inscalarop) then		(* expecting some args *)
  begin
  i := 0;
  nhdr := nil;
  d := nil;
  nargs := 1;
  absp := false;
  aref := false;
  func := false;
  qp := false;
  closep := true;
  b := true;
  paramlist := nil;
  case opn↑.op of
atan2op,
tmakeop,
fmakeop,
vsaxwrop,
dacop:	nargs := 2;
vmakeop,
constrop: nargs := 3;
queryop: begin
	 qp := true;
	 nargs := 99;			(* variable number of args *)
	 end;
absop:	absp := true;
arefop:	begin
	aref := true;
	n := opn↑.arg1↑.vari↑.a;	(* check it's defined *)
	if n = nil then nargs := 1 else nargs := n↑.numdims;
	end;
callop:	begin
	func := true;
	nargs := 0;
	n := opn↑.arg1↑.vari↑.p;	(* see if procedure is defined *)
	if n <> nil then
	  begin
	  paramlist := n↑.paramlist;
	  if paramlist = nil then closep := false;
	  end;
	end;
otherwise {do nothing};
   end;
  if not absp then
    begin
    getToken;			(* looking for opening '(' or '[' *)
    if aref then dch := '[' else dch := '(';
    with curToken do
     if (ttype <> delimtype) or (ch <> dch) then  (* not there - complain *)
      begin
      backup := true;
      if opn↑.op = timeop then
	begin
	b := false;		(* don't bother looking for args *)
	closep := false;	(* so we know not to expect a closing ')' *)
	opn↑.arg1 := defNode(svaltype);	(* use zero *)
	i := 1;
	end
       else if qp or not closep then  (* query doesn't need to take any args *)
	begin
	b := false;		(* don't bother looking for args *)
	closep := false;	(* so we know not to expect a closing ')' *)
	end
       else
	begin
	pp10L('Need a "  ',8); ppChar(dch); pp10('" here    ',6);
	errprnt;
	end;
      end;
    end;
  while b do
   begin					(* get the next argument *)
   if paramlist = nil then arg := exprParse	(* implies (not func) *)
    else if paramlist↑.tbits <> 5 then arg := exprParse
    else
     with curToken do
      begin			(* looking for array passed by reference *)
      getToken;
      bp := ttype = identtype;
      if bp then
	begin			 (* is it a defined variable and an array? *)
	v := varLookup(id);
	if v <> nil then bp := (v↑.vtype <> pconstype) and odd(v↑.tbits)
	 else bp := false;
	end;
      if bp then
	begin
	arg := newNode;
	arg↑.ntype := leafnode;
	arg↑.ltype := varitype;
	arg↑.vari := v;
	arg↑.vid := v↑.name;
	end
       else				(* no good *)
	begin
	pp20L('Need an array variab',20); pp10('le here   ',7);
	errprnt;
	arg := nil;
	end;
      end;
   if arg <> nil then		(* got one *)
     begin
     i := i + 1;
     if func or aref or qp then	(* add to arg list *)
       begin
       np := newNode;
       np↑.ntype := listnode;
       if func and (paramlist <> nil) then
	 with paramlist↑ do
	  begin		(* check parameter for correct data type *)
	  np↑.lval := checkarg(arg,vtype);
	  if dtype <> nil then d := dtype↑.dim	(* use dimension if it exists *)
	   else					(* otherwise use default *)
	    if (vtype = transtype) or (vtype = frametype) then
	      d := distancedim↑.dim
	     else if vtype = rottype then d := angledim↑.dim
	     else d := nodim↑.dim;
	  checkdim(arg,d);
	  d := nil;
	  paramlist := next;
	  if paramlist = nil then nargs := i;
	  end
	else if aref then
	 begin
	 np↑.lval := checkarg(arg,svaltype);
	 checkdim(arg,nodim↑.dim);
	 end
	else np↑.lval := arg;
       if nhdr = nil then nhdr := np else n↑.next := np;
       n := np;
       n↑.next := nil;
       end
      else
       begin
       with opn↑ do
	case i of
    1:	 arg1 := arg;
    2:	 arg2 := arg;
    3:	 arg3 := arg;
	 end;
       end;
     getToken;				(* looking for separating ',' *)
     with curToken do
      if (ttype <> delimtype) or (ch <> ',') then b := false (* that's it *)
     end
    else b := false;
   end;
  if absp then			(* looking for closing '|' *)
    begin
    with curToken do
     if (ttype <> reswdtype) or (rtype <> optype) or (op <> absop) then
      begin			(* not there - complain *)
      backup := true;
      pp10('Need a "  ',8); ppChar(chr(174B)); pp10('" here    ',6);
      errprnt;
      end;
    if opn↑.arg1 = nil then opn↑.arg1 := defNode(svaltype);
    dat := getdtype(opn↑.arg1);	(* now figure out what sort of || we've got *)
    if dat = svaltype then opn↑.op := sabsop
     else if dat = vectype then opn↑.op := vmagnop
     else opn↑.op := tmagnop;
    end
   else if closep then
    begin
    if aref then dch := ']' else dch := ')';
    backup := true;			(* looking for closing ')' or ']' *)
    getDelim(dch);
    end
   else backup := true;
  if func or aref then		(* store arg list in arg 2 *)
    begin
    while (i < nargs) or (paramlist <> nil) do
     begin		  (* make sure we return the right size arg list *)
     i := i + 1;
     np := newNode;
     np↑.ntype := listnode;
     if func and (paramlist <> nil) then
       begin
       np↑.lval := defNode(paramlist↑.vtype);
       paramlist := paramlist↑.next;
       if paramlist = nil then nargs := i;
       end
      else np↑.lval := defNode(svaltype);
     if nhdr = nil then nhdr := np else n↑.next := np;
     n := np;
     n↑.next := nil;
     end;
    opn↑.arg2 := nhdr;
    end
   else if qp then opn↑.arg2 := nhdr		(* store arg list in arg 2 *)
   else
    with opn↑ do
     case op of		(* check args are of proper type & dimension *)
sqrtop:	  check1(svaltype);
logop,
expop,
asinop,
acosop,
adcop:	  begin
	  check1(svaltype);
	  checkdim(arg1,nodim↑.dim);
	  end;
timeop:   begin
	  check1(svaltype);
	  checkdim(arg1,timedim↑.dim);
	  end;
sinop,
cosop,
tanop:	  begin
	  check1(svaltype);
	  checkdim(arg1,angledim↑.dim);
	  end;
dacop,
atan2op:  begin
	  check2(svaltype,svaltype);
	  checkdim(arg1,nodim↑.dim);
	  checkdim(arg2,nodim↑.dim);
	  end;
vmakeop:  begin
	  check3(svaltype,svaltype,svaltype);
	  checkdim(arg2,getdim(arg1,d));
	  checkdim(arg3,d);
	  end;
unitvop:  check1(vectype);
vsaxwrop: begin
	  check2(vectype,svaltype);
	  checkdim(arg2,angledim↑.dim);
	  end;
tposop,
torientop,
tinvrtop: check1(transtype);
taxisop:  check1(rottype);
fmakeop,
tmakeop:  begin
	  check2(rottype,vectype);
	  checkdim(arg1,angledim↑.dim);
	  if op = fmakeop then checkdim(arg2,distancedim↑.dim);
	  end;
deproachop: begin
	  check1(frametype);
	  checkdim(arg1,distancedim↑.dim);
	  end;
constrop: begin
	  check3(vectype,vectype,vectype);
	  checkdim(arg1,distancedim↑.dim);
	  checkdim(arg2,distancedim↑.dim);
	  checkdim(arg3,distancedim↑.dim);
	  end;
otherwise {do nothing};
      end;
  if aref then				(* if array, check it's defined *)
   if opn↑.arg1↑.vari↑.a = nil then nargs := i;	(* it's not, assume all ok *)
  if (not qp) and (i <> nargs) then
   begin
   pp10L('Need      ',4); ppInt(nargs); pp20(' arguments here     ',15);
   errprnt;
   end;
  if d <> nil then relNode(d);		(* done with dimension node *)
  end;
end;

(* function to parse expressions: exprParse *)

function exprParse { : nodep };
 var expstack, opstack: nodep; precstack: array [0..10] of integer;
     opsp,i,j: integer; n,np: nodep; vp: varidefp; opseen,done,badp: boolean;

 function badexpr: nodep;
  var n: nodep;
  begin
  n := newNode;
  badexpr := n;
  with n↑ do
   begin ntype:= exprnode; op:= badop; arg1:= nil; arg2:= newNode; arg3:= nil end;
  n := n↑.arg2;
  with n↑ do begin ntype := leafnode; ltype := transtype; t := niltrans end;
  if not badp then
   begin
   pp20L('Bad expression      ',14);
   errprnt;
   badp := true;
   end;
  end;

 function gettype(n: nodep): datatypes;
  var d: datatypes;
  begin
  d := getdtype(n);
  if (d = rottype) or (d = frametype) then d := transtype;
  gettype := d;
  end;

 procedure pushexp(n: nodep);
  begin
  n↑.next := expstack;
  expstack := n;
  end;

 procedure cpushexp(n: nodep);
  begin
  if opseen then pushexp(n)		(* all okay *)
   else
    begin			(* yow! - we just saw an operand - complain *)
    pp20L('Bad expression - con',20); pp20('secutive operands   ',17);
    errprnt;
    end;
  opseen := false;			(* expecting an operator *)
  end;

 function popexp: nodep;
  var n: nodep;
  begin
  if expstack <> nil then
    begin
    n := expstack;
    expstack := expstack↑.next;
    n↑.next := nil;
    popexp := n;
    end
   else
    begin			(* this probably can't happen, but... *)
    pp20L('Gack! - parse operan',20); pp20('d expression stack u',20);
    pp10('nderflow  ',8);
    errprnt;
    popexp := badexpr;
    end;
  end;

 procedure pushop;
  begin
  if opsp <= 9 then
    begin
    n↑.next := opstack;
    opstack := n;
    opsp := opsp + 1;
    precstack[opsp] := i;
    end
   else
    begin
    pp20L('Gack! - parse operat',20); pp20('or expression stack ',20);
    pp10('overflow  ',8);
    errprnt;
    end;
  opseen := true;			(* expecting an operand *)
  end;

 procedure popop;
  var n,n1,d: nodep; d1,d2: datatypes;
  begin
  d := nil;
  n := opstack;
  opstack := n↑.next;
  opsp := opsp - 1;
  with n↑ do
   begin				(* get its operand(s) *)
   next := nil;
   arg3 := nil;
   if (op = negop) or (op = notop) then arg2 := nil
    else
     begin
     arg2 := popexp;
     if expstack = nil then
       begin				(* whoops - wasn't any arg 2 *)
       expstack := arg2;
       arg2 := badexpr;
       end;
     end;
   arg1 := popexp;
   if op <= modop then
     begin
     arg1 := checkarg(arg1,svaltype);		(* check datatypes of args *)
     if op <> notop then arg2 := checkarg(arg2,svaltype);
     if (op <= sneop) or (op >= maxop) then	(* relation, max, min & mod *)
       begin
       if (op <> intop) and (op <> idivop) then	(* don't care about these *)
	 checkdim(arg2,getdim(arg1,d)); (* does arg2 match dimension of arg1 *)
       end
      else if op <= sexpop then			(* check dimensions too *)
       begin					(* args better be dimensionless *)
       checkdim(arg1,nodim↑.dim);
       if op <> notop then checkdim(arg2,nodim↑.dim);
       end
     end
    else if op = vdotop then
     begin
     arg1 := checkarg(arg1,vectype);
     arg2 := checkarg(arg2,vectype);
     end
    else if op = wrtop then
     begin
     arg1 := checkarg(arg1,vectype);
     arg2 := checkarg(arg2,transtype);
     end
    else if op = ftofop then
     begin
     arg1 := checkarg(arg1,transtype);
     arg2 := checkarg(arg2,transtype);
     checkdim(arg2,getdim(arg1,d)); (* does arg2 match dimension of arg1 *)
     end
    else if op >= addop then	(* need to determine proper op for given args *)
     case op of
negop:	begin				(* see if snegop or vnegop *)
	d1 := getdtype(arg1);
	if d1 = svaltype then op := snegop
	 else if d1 = vectype then op := vnegop
	 else begin n1 := badexpr; n1↑.arg1 := n; n := n1 end;
	end;
addop:	begin
	checkdim(arg2,getdim(arg1,d)); (* does arg2 match dimension of arg1 *)
	d1 := gettype(arg1);
	d2 := gettype(arg2);
	if d1 = undeftype then begin d1 := d2; arg1↑.vari↑.vtype := d1 end;
	if d2 = undeftype then
	  begin
	  if d1 = transtype then d2 := vectype else d2 := d1;
	  arg2↑.vari↑.vtype := d2
	  end;
	if (d1 = svaltype) and (d2 = svaltype) then op := saddop
	 else if (d1 = vectype) and (d2 = vectype) then op := vaddop
	 else if (d1 = transtype) and (d2 = vectype) then op := tvaddop
	 else begin op := saddop; n1 := badexpr; n1↑.arg1 := n; n := n1 end;
	end;
subop:	begin
	checkdim(arg2,getdim(arg1,d)); (* does arg2 match dimension of arg1 *)
	d1 := gettype(arg1);
	d2 := gettype(arg2);
	if d1 = undeftype then begin d1 := d2; arg1↑.vari↑.vtype := d1 end;
	if d2 = undeftype then
	  begin
	  if d1 = transtype then d2 := vectype else d2 := d1;
	  arg2↑.vari↑.vtype := d2
	  end;
	if (d1 = svaltype) and (d2 = svaltype) then op := ssubop
	 else if (d1 = vectype) and (d2 = vectype) then op := vsubop
	 else if (d1 = transtype) and (d2 = vectype) then op := tvsubop
	 else begin op := ssubop; n1 := badexpr; n1↑.arg1 := n; n := n1 end;
	end;
mulop:	begin
	d1 := gettype(arg1);
	d2 := gettype(arg2);
	if d1 = undeftype then begin d1 := d2; arg1↑.vari↑.vtype := d1 end;
	if d2 = undeftype then begin d2 := d1; arg2↑.vari↑.vtype := d2 end;
	if (d1 = svaltype) and (d2 = svaltype) then op := smulop
	 else if (d1 = svaltype) and (d2 = vectype) then op := svmulop
	 else if (d1 = vectype) and (d2 = svaltype) then op := vsmulop
	 else if (d1 = vectype) and (d2 = vectype) then op := crossvop
	 else if (d1 = transtype) and (d2 = vectype) then op := tvmulop
	 else if (d1 = transtype) and (d2 = transtype) then op := ttmulop
	 else begin op := smulop; n1 := badexpr; n1↑.arg1 := n; n := n1 end;
        if (op = ttmulop) or (op = tvmulop) then
	 if getDtype(arg1) <> rottype then
	  checkdim(arg2,getdim(arg1,d)); (* does arg2 match dimension of arg1 *)
	end;
divop:	begin
	d1 := gettype(arg1);
	d2 := gettype(arg2);
	if d1 = undeftype then
	  begin d1 := svaltype; arg1↑.vari↑.vtype := d1 end;
	if d2 = undeftype then
	  begin d2 := svaltype; arg2↑.vari↑.vtype := d2 end;
	if (d1 = svaltype) and (d2 = svaltype) then op := sdivop
	 else if (d1 = vectype) and (d2 = svaltype) then op := vsdivop
	 else begin op := sdivop; n1 := badexpr; n1↑.arg1 := n; n := n1 end;
	end;
otherwise {do nothing};
     end;
   pushexp(n);		(* save it as operand for next operator *)
   if d <> nil then relNode(d);
   end;
  end;

 function opprecedence(op: exprtypes): integer;
  var i: integer;
  begin
  i := 0;
    case op of
eqvop:	i := 1;
orop,
xorop:	i := 2;
andop:	i := 3;
sltop,
sleop,
seqop,
sgeop,
sgtop,
sneop:	i := 4;
addop,
subop:	i := 5;
wrtop:	i := 6;
mulop,
divop,
maxop,
minop,
idivop,
modop,
vdotop: i := 7;
sexpop,
ftofop:	i := 8;
negop,
notop:	i := 9;
otherwise {do nothing - should not happen};
   end;

  opprecedence := i;
  end;

 begin
 expstack := nil;
 opstack := nil;
 opsp := 0;
 precstack[0] := -1;
 done := false;
 opseen := true;			(* expecting an operand *)
 badp := false;			(* haven't complained about expression yet *)

 repeat
 getToken;
 with curToken do
  begin
  case ttype of				(* see what we've got *)
labeldeftype:
    begin done := true; backup := true end;
delimtype:
    if ch = '(' then
      begin
      cpushexp(exprParse);		(* get the parenthesized expression *)
      getDelim(')');			(* get the closing ')' *)
      end
     else begin done := true; backup := true end;
reswdtype:
    if rtype <> optype then begin done := true; backup := true end
     else if not opseen and (op = absop) then
      begin done := true; backup := true end
     else if not (opseen and (op = addop)) then	(* we want to ignore unary + *)
      begin
      if opseen and (op = subop) then op := negop;
      n := newNode;
      n↑.ntype := exprnode;
      n↑.op := op;
      i := opprecedence(op);
      if i = 0 then			(* really an operand *)
	begin
	getargs(n);			(* get any arguments op needs *)
	cpushexp(n);			(* save operand for its operator *)
	end
       else if opseen and ((op <> negop) and (op <> notop)) then
	begin			(* yow! - we just saw an operator - complain *)
	pp20L('Bad expression - con',20); pp20('secutive operators  ',18);
	errprnt;
	end
       else if i > precstack[opsp] then (* higher precedence so push on stack *)
	pushop
       else				(* lower precedence *)
	begin
	while (i <= precstack[opsp]) and (i < 9) do popop; (* 9 = prec(not,neg) *)
	pushop;
	end;
      end;
constype: cpushexp(cons);
identtype:
    begin
    vp := varLookup(id);
    if vp = nil then
      begin				(* undefined variable *)
      vp := makeUVar(undeftype,id);	(* define it somewhat *)
      i := curChar;
      getToken;		(* see if it's supposed to be a procedure or array *)
      backup := true;		(* we're just peeking *)
      pp10L(' Undeclare',10);
      if (ttype = delimtype) and ((ch = '(') or (ch = '[')) then
	if ch = '[' then
	  begin
	  vp↑.tbits := 1;	(* array *)
	  vp↑.a := nil;
	  pp20('d array variable    ',16);
	  end
	 else
	  begin
	  vp↑.tbits := 2;	(* procedure *)
	  vp↑.p := nil;
	  pp20('d procedure         ',11);
	  end
       else pp10('d variable',10);
      pp20(' - will try to defin',20); pp5('e it.',5);
      j := curChar;
      curChar := i;		(* use where we were before we peeked *)
      errprnt;
      curChar := j;
      end;
    if vp↑.vtype = pconstype then		(* constant *)
      begin
      np := newNode;			(* need to make a pointer to it *)
      with np↑ do
	begin
	ntype := leafnode;
	ltype := pconstype;
	cname := vp;
	pcval := vp↑.c;
	end;
      cpushexp(np);
      end
     else if odd(vp↑.tbits) or (vp↑.tbits = 2) then
      begin			(* array reference or procedure call *)
      n := newNode;
      with n↑ do
	begin
	ntype := exprnode;
	if odd(vp↑.tbits) then op := arefop else op := callop;
	arg1 := newNode;
	end;
      with n↑.arg1↑ do
	begin
	ntype := leafnode;
	ltype := varitype;
	vari := vp;
	vid := vp↑.name;
	end;
      getargs(n);		(* get subscripts/parameters *)
      cpushexp(n);
      end
     else				(* variable *)
      begin
      n := newNode;
      with n↑ do
	begin
	ntype := leafnode;
	ltype := varitype;
	vari := vp;
	vid := vp↑.name;
	end;
      cpushexp(n);
      end;
    end;
otherwise {do nothing};
   end;
  end;
 until done;

 while opsp > 0 do popop;		(* bind the rest of the operators *)
 if expstack <> nil then exprParse := popexp (* return what's left on stack *)
  else exprParse := nil;
 while expstack <> nil do relNode(popexp);  (* probably don't need, but... *)
 end;